home *** CD-ROM | disk | FTP | other *** search
/ Macwelt 1 / Macwelt DVD 1.toast / Web-Publishing / HTML-Editoren / Alpha ƒ / Tcl / Modes / HTML and CSS Modes / htmlCheckLinks.tcl < prev    next >
Encoding:
Text File  |  2001-01-12  |  26.2 KB  |  693 lines
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  HTML mode - tools for editing HTML documents
  4.  # 
  5.  #  FILE: "htmlCheckLinks.tcl"
  6.  #                                    created: 97-06-26 12.51.42 
  7.  #                                last update: 00-12-30 20.54.37 
  8.  #  Author: Johan Linde
  9.  #  E-mail: <alpha_www_tools@go.to>
  10.  #     www: <http://go.to/alpha_www_tools>
  11.  #  
  12.  # Version: 3.0
  13.  # 
  14.  # Copyright 1996-2001 by Johan Linde
  15.  #  
  16.  # This program is free software; you can redistribute it and/or modify
  17.  # it under the terms of the GNU General Public License as published by
  18.  # the Free Software Foundation; either version 2 of the License, or
  19.  # (at your option) any later version.
  20.  # 
  21.  # This program is distributed in the hope that it will be useful,
  22.  # but WITHOUT ANY WARRANTY; without even the implied warranty of
  23.  # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24.  # GNU General Public License for more details.
  25.  # 
  26.  # You should have received a copy of the GNU General Public License
  27.  # along with this program; if not, write to the Free Software
  28.  # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  29.  # 
  30.  # ###################################################################
  31.  ##
  32.  
  33. #===============================================================================
  34. # This file contains the procs for the Check Links submenu.
  35. #===============================================================================
  36.  
  37. # Check that links are valid.
  38. proc html::CheckWindow {} {html::CheckLinks Window}
  39. proc html::CheckHomePage {} {html::CheckLinks Home}
  40. proc html::CheckFolder {} {html::CheckLinks Folder}
  41. proc html::CheckFile {} {html::CheckLinks File}
  42.  
  43. # Checks if a folder contains a home page folder or an include folder as a subfolder.
  44. proc html::ContainHpFolder {folder} {
  45.     global HTMLmodeVars
  46.     foreach p $HTMLmodeVars(homePages) {
  47.         foreach i {0 4} {
  48.             if {[llength $p] == $i} {continue}
  49.             if {[string match [file join $folder *] [file join [lindex $p $i] " "]] && 
  50.             [file join [lindex $p $i] " "] != [file join $folder " "]} {
  51.                 return 1
  52.             }
  53.         }
  54.     }
  55.     return 0
  56. }
  57.  
  58.  
  59. proc html::CheckLinks {where {checking 1}} {
  60.     global HTMLmodeVars
  61.         
  62.     # Save all open window?
  63.     if {$where != "Window" && 
  64.     [html::AllSaved "-c {Save all open windows before checking links?}"] == "cancel"} { return}
  65.     set filebase 0
  66.     if {$where == "File"} {
  67.         if {[catch {getfile "Select file to scan."} files]} {return}
  68.         # Is this a text file?
  69.         if {![html::IsTextFile $files alertnote]} {return}
  70.         set base [html::BASEfromPath $files]
  71.         if {$HTMLmodeVars(useBigBrother)} {html::BigBrother "$files"; return}
  72.         set path [lindex $base 1]
  73.         set homepage [lindex $base 3]
  74.         set isinfld [lindex $base [expr {3 + [lindex $base 4] / 2}]]
  75.         set base [lindex $base 0]
  76.         if {$base == "file:///"} {set filebase [expr {[string length [file dirname $files]] + 1}]}
  77.         set filelist [html::OpenAfile]
  78.         puts [lindex $filelist 0] $files
  79.         close [lindex $filelist 0]
  80.         set files [lindex $filelist 1]
  81.     } elseif {$where == "Window"} {
  82.         set files [html::StrippedFrontWindowPath]
  83.         if {![file exists $files]} {
  84.             if {[lindex [dialog -w 200 -h 70 -t "You must save the window." 10 10 390 30  \
  85.             -b Save 20 40  85 60 \
  86.             -b Cancel 110 40 175 60] 1]} {
  87.                 error ""
  88.             }
  89.             if {![catch {saveAs}]} {
  90.                 set files [html::StrippedFrontWindowPath]
  91.             } else {
  92.                 error "" 
  93.             }
  94.         } else {
  95.             if {[winDirty] && [askyesno "Save window?"] == "yes"} {save}
  96.         }
  97.         set base [html::BASEfromPath $files]
  98.         if {$checking != 2 && $HTMLmodeVars(useBigBrother)} {html::BigBrother "$files"; return}
  99.         set path [lindex $base 1]
  100.         set homepage [lindex $base 3]
  101.         set isinfld [lindex $base [expr {3 + [lindex $base 4] / 2}]]
  102.         set base [lindex $base 0]
  103.         if {$base == "file:///"} {set filebase [expr {[string length [file dirname $files]] + 1}]}
  104.         set filelist [html::OpenAfile]
  105.         puts [lindex $filelist 0] $files
  106.         close [lindex $filelist 0]
  107.         set files [lindex $filelist 1]
  108.     } elseif {$where == "Folder"} {
  109.         if {[catch {html::GetDir "Folder to scan."} folder]} {return}
  110.         set base [html::BASEfromPath $folder]
  111.         set subFolders [expr {![string compare yes [askyesno "Check files in subfolders?"]]}]
  112.         if {$subFolders && ![set subFolders [expr {![html::ContainHpFolder $folder]}]] &&
  113.         [lindex [dialog -w 410 -h 135 -t "The folder '[file tail $folder]' contains a\
  114.         home page folder or an include folder, but is itself not inside one. You can't\
  115.         simultaneously check links both inside and outside home page or include folders.\
  116.         Sorry!\rBut\
  117.         you can still check this folder and skip the subfolders." 10 10 400 90\
  118.         -b Check 20 105 85 125 -b Cancel 110 105 175 125] 1]} {return}
  119.         if {$HTMLmodeVars(useBigBrother)} {html::BigBrother [string trimright [file join $folder " "]] $subFolders; return}
  120.         set path [lindex $base 1]
  121.         set homepage [lindex $base 3]
  122.         set isinfld [lindex $base [expr {3 + [lindex $base 4] / 2}]]
  123.         set base [lindex $base 0]
  124.         if {$base == "file:///"} {set filebase [expr {[string length $folder] + 1}]}
  125.         if {$subFolders} {
  126.             set files [html::AllHTMLfiles $folder 1]
  127.         } else {
  128.             set files [html::GetHTMLfiles $folder 1]
  129.         }
  130.     } else {
  131.         # Check that a home page is defined.
  132.         if {![html::IsThereAHomePage]} {return}
  133.         if {[catch {html::WhichHomePage "check links in"} hp]} {return}
  134.         set homepage [lindex $hp 0]
  135.         set isinfld $homepage
  136.         if {$HTMLmodeVars(useBigBrother)} {html::BigBrother [string trimright [file join $homepage " "]] 1; return}
  137.         set files [html::AllHTMLfiles $homepage 1]
  138.         set base [lindex $hp 1]
  139.         set path [lindex $hp 2]
  140.     }
  141.     return [html::ScanFiles $files $base $path $homepage $isinfld $checking $filebase]
  142. }
  143.  
  144. # Select a new file for an invalid link.
  145. proc html::LinkToNewFile {} {
  146.     if {![string match "*Invalid URLs*" [set win [lindex [winNames] 0]]] || [lindex [posToRowCol [getPos]] 0] < 3} {return}
  147.     set str [getText [lineStart [getPos]] [pos::math [nextLineStart [getPos]] - 1]]
  148.     browse::Goto
  149.     regexp {Line [0-9]+:([^∞]+)} $str dum url
  150.     regsub -all {\((BASE|Invalid|anchor|case)[^\)]+\)} $url "" url
  151.     set url [string trim $url]
  152.     set str ""
  153.     regexp {[^#]*} $url str
  154.     set anchor [string trim [string range $url [string length $str] end] "\"' \t\r\n"]
  155.     regsub -all {[\(\)]} $url {\\\0} url
  156.     regsub { *= *} $url "\[ \t\r\n\]*=\[ \t\r\n\]*" url1
  157.     if {[catch {search -s -f 1 -i 0 -r 1 -m 0 $url1 [getPos]} res] || 
  158.     [pos::compare [lindex $res 0] > [selEnd]]} {
  159.         alertnote "Can't find link to change on selected line."
  160.         return
  161.     }
  162.     if {[set newFile [html::GetFile 0]] == ""} {return}
  163.     set newLink [lindex $newFile 0]
  164.     set wh [lindex $newFile 1]
  165.     if {$wh == "" && $anchor != "" && [html::CheckAnchor $pathToNewFile [string trim $url "\"' \t\r\n"]]} {
  166.         append newLink $anchor
  167.     }
  168.     set f [html::URLescape2 $newLink]
  169.     if {![regsub "(\[^=\]+\[ \t\r\n\]*=\[ \t\r\n\]*)(\"\[^\"\]+\"|'\[^'\]+'|\[^ \]+)" \
  170.       [eval getText $res] "\\1\"$f\"" url]} {set url url(\"$f\")}
  171.     replaceText [set start [lindex $res 0]] [lindex $res 1] $url
  172.     # If it's an IMG tag, replace WIDTH and HEIGHT.
  173.     if {$wh != "" && [string toupper [string range $url 0 2]] == "SRC" &&
  174.     ![catch {search -s -f 0 -i 1 -r 1 -m 0 {<IMG[ \t\r\n]+[^<>]+>} $start} res1] &&
  175.     [pos::compare [lindex $res1 1] > [lindex $res 1]]} {
  176.         if {![catch {search -s -f 1 -i 1 -r 1 -m 0 -l [expr {[lindex $res1 1] + 1}] \
  177.           {WIDTH[ \t\r\n]*=[ \t\r\n]*("[0-9]*"|'[0-9]*'|[0-9]*)} [lindex $res1 0]} res2]} {
  178.             regsub -nocase "(WIDTH\[ \t\r\n\]*=\[ \t\r\n\]*)(\"\[0-9\]*\"|'\[0-9\]*'|\[0-9\]*)" \
  179.               [eval getText $res2] "\\1\"[lindex $wh 0]\"" ww
  180.             replaceText [lindex $res2 0] [lindex $res2 1] $ww
  181.         }
  182.         if {![catch {search -s -f 1 -i 1 -r 1 -m 0 -l [expr {[lindex $res1 1] + 1}] \
  183.           {HEIGHT[ \t\r\n]*=[ \t\r\n]*("[0-9]*"|'[0-9]*'|[0-9]*)} [lindex $res1 0]} res2]} {
  184.             regsub -nocase "(HEIGHT\[ \t\r\n\]*=\[ \t\r\n\]*)(\"\[0-9\]*\"|'\[0-9\]*'|\[0-9\]*)" \
  185.               [eval getText $res2] "\\1\"[lindex $wh 1]\"" hh
  186.             replaceText [lindex $res2 0] [lindex $res2 1] $hh
  187.         }
  188.     }
  189.     # Remove line with corrected link.
  190.     bringToFront $win
  191.     setWinInfo read-only 0
  192.     deleteText [lineStart [getPos]] [nextLineStart [getPos]]
  193.     select [lineStart [getPos]] [nextLineStart [getPos]]
  194.     setWinInfo dirty 0
  195.     setWinInfo read-only 1
  196. }
  197.  
  198. Bind '\r' <o> html::LinkToNewFile Brws
  199. Bind enter <o> html::LinkToNewFile Brws
  200.  
  201. proc html::BbthReadSettings {} {
  202.     set allSettings [AEBuild -r 'Bbth' core getd ---- "obj{want:type('reco'),from:null(),form:'prop',seld:type('allS')}"]
  203.     set allSettings [string range $allSettings 17 [expr {[string length $allSettings] - 2}]]
  204.     return $allSettings
  205. }
  206.  
  207. proc html::BbthRestoreSettings {settings} {
  208.     AEBuild 'Bbth' core setd "----" "obj{want:type('reco'),from:null(),form:'prop',seld:type('allS')}" "data" $settings
  209. }
  210.  
  211. proc html::BigBrother {path {searchSubFolder 0}} {
  212.     global HTMLmodeVars
  213.     # define url mapping
  214.     set urlmap [html::URLmap]
  215.     # launches Big Brother
  216.     if {![app::isRunning Bbth] && [catch {app::launchBack Bbth}]} {
  217.         alertnote "Could not find or launch Big Brother."
  218.         return
  219.     }
  220.     if {[set vers [html::GetVersion Bbth]] >= 1.1} {
  221.         # Read all settings.
  222.         set allSettings [html::BbthReadSettings]
  223.         # Change settings
  224.         if {!$HTMLmodeVars(useBBoptions)} {
  225.             AEBuild 'Bbth' core setd "----" "obj{want:type('bool'),from:null(),form:'prop',seld:type('Loly')}" "data" "bool(«0$HTMLmodeVars(ignoreRemote)»)"
  226.             AEBuild 'Bbth' core setd "----" "obj{want:type('bool'),from:null(),form:'prop',seld:type('Roly')}" "data" "bool(«0$HTMLmodeVars(ignoreLocal)»)"
  227.         }
  228.         AEBuild 'Bbth' core setd "----" "obj{want:type('bool'),from:null(),form:'prop',seld:type('Sfld')}" "data" "bool(«0$searchSubFolder»)"
  229.         AEBuild 'Bbth' core setd "----" "obj{want:type('mapG'),from:null(),form:'prop',seld:type('mapS')}" "data" "\[$urlmap\]"
  230.         if {$vers >= 1.2} {
  231.             AEBuild 'Bbth' core setd "----" "obj{want:type('bool'),from:null(),form:'prop',seld:type('CasS')}" "data" "bool(«0$HTMLmodeVars(caseSensitive)»)"        
  232.         }
  233.     } else {
  234.         alertnote "Cannot change the settings in Big Brother. You need Big Brother 1.1 or later."
  235.     }
  236.     # Sends a file or folder to be opened.
  237.     sendOpenEvent noReply 'Bbth' $path
  238.     # Restore settings
  239.     if {$vers >= 1.1} {html::BbthRestoreSettings $allSettings}
  240.     if {$HTMLmodeVars(checkInFront)} {switchTo 'Bbth'}
  241. }
  242.  
  243.  
  244. #  Checking of remote links in a document
  245. proc html::CheckRemoteLinks {} {
  246.     global htmlNumBbthChecking
  247.     if {[html::GetVersion Bbth] < 1.2} {
  248.         alertnote "You need Big Brother 1.2 or later to check and fix remote links."
  249.         return
  250.     }
  251.     set urlList [html::CheckLinks Window 2]
  252.     if {![llength $urlList]} {alertnote "No remote links to check."; return}
  253.     if {![app::isRunning Bbth] && [catch {app::launchBack Bbth}]} {
  254.         alertnote "Could not find or launch Big Brother."
  255.         return
  256.     }
  257.     set htmlBbthChkdWin [html::StrippedFrontWindowPath]
  258.     set sep ""
  259.     foreach url $urlList {
  260.         append theRecord "$sep{Url :“[lindex $url 1]”, Id# :“[concat $url $htmlBbthChkdWin]”}"
  261.         set sep ", "
  262.     }
  263.     # Read all settings.
  264.     set allSettings [html::BbthReadSettings]
  265.     
  266.     # Don't ignore remote links
  267.     AEBuild 'Bbth' core setd "----" "obj{want:type('bool'),from:null(),form:'prop',seld:type('Loly')}" "data" "bool(«00»)"
  268.     # No url mappings.
  269.     AEBuild 'Bbth' core setd "----" "obj{want:type('mapG'),from:null(),form:'prop',seld:type('mapS')}" "data" "\[\]"
  270.     AEBuild 'Bbth' "Bbth" "Chck" "----" "\[$theRecord\]"
  271.     html::BbthRestoreSettings $allSettings
  272.     incr htmlNumBbthChecking [llength $urlList]
  273. }
  274.  
  275. # Takes care of events sent from Big Brother.
  276. proc html::BbthChkdHandler {arg} {
  277.     global tileLeft tileTop tileWidth errorHeight htmlNumBbthChecking
  278.     regexp {'Id# ':“([^”]+)”} $arg dum id
  279.     regexp {CRes:([^,]+)} $arg dum result
  280.     set win [lrange $id 2 end]
  281.     switch $result {
  282.         RSuc {set str "The remote document exists."; set color 3}
  283.         LSuc {set str "The local document exists."; set color 3}
  284.         SFld {
  285.             set color 5
  286.             regexp {SCod:([^,]+)} $arg dum code
  287.             switch $code {
  288.                 "204" {set str "The document exists but contains no data."}
  289.                 "400" {set str "The server (or the proxy) reports a bad request."}
  290.                 "401" {set str "The document seems to exist but a password is required to access it."}
  291.                 "403" {set str "The document still exists but the server refuses to deliver it."}
  292.                 "404" {set str "The remote document doesn't exist."}
  293.                 "500" {set str "The server reports an internal error while trying to serve our request."}
  294.                 "501" {set str "The server doesn't seem to support checking the existence of a link."}
  295.                 "502" {set str "A gateway reported an error."}
  296.                 "503" {set str "The server is currently unable to deliver this document. This situation might be temporary."}
  297.                 default {set str "The server answered with an unknown HTTP response code."}
  298.             }
  299.         }
  300.         SMvd {
  301.             set color 1
  302.             regexp {SCod:([^,]+)} $arg dum code
  303.             regexp {nURL:“([^”]+)”} $arg dum newURL
  304.             switch $code {
  305.                 "301" {set str "The document has moved permanently to $newURL."}
  306.                 "302" {set str "The document has moved temporarily to $newURL."}
  307.                 default {set str "The document has moved to $newURL."}
  308.             }
  309.             edit -c -w $win
  310.             set l [rowColToPos [lindex $id 0] 0]
  311.             if {![catch {search -s -f 1 -i 1 -m 0 -r 0 -l [nextLineStart $l] [lindex $id 1] [lineStart $l]} res]} {
  312.                 eval replaceText $res $newURL
  313.             }
  314.         }
  315.         sFld {
  316.             set color 5
  317.             regexp {sRsn:([^,]+)} $arg dum reason
  318.             switch $reason {
  319.                 bnAb {set str "Invalid base URL: it should be an absolute URL."}
  320.                 nTCP {set str "MacTCP or Open Transport TCP/IP is needed to check remote links."}
  321.                 locF {set str "Invalid local link."}
  322.                 Open {set str "Initializing the network services failed."}
  323.                 Bind {set str "Selecting a local port failed."}
  324.                 Rslv {set str "Resolving the host name failed."}
  325.                 Conn {set str "Establishing the connection failed."}
  326.                 Send {set str "Sending the request failed."}
  327.                 Recv {set str "Receiving the server's answer failed."}
  328.                 Disc {set str "Closing the connection failed."}
  329.                 Pars {set str "The server's response doesn't conform to the HTTP/1.0 protocol."}
  330.                 Empt {set str "The server closed the connection without answering."}
  331.                 IncT {set str "The server sent only part of the document."}
  332.                 SWDr {set str "The server said the document exists, but wasn't able to deliver it."}
  333.                 NTr/ {set str "This URL should end with a slash because it points to a directory."}
  334.                 default {set str "Checking the link failed for an unknown reason."}
  335.             }
  336.         }
  337.         Sntx {set str "URL syntax error."; set color 5}
  338.     }
  339.     if {[lsearch -exact [html::AllWindowPaths] "* Remote URLs *"] < 0} {
  340.         new -n "* Remote URLs *" -g $tileLeft $tileTop $tileWidth $errorHeight -m Brws
  341.         insertText "Link checking results:  (<uparrow> and <downarrow> to browse, <return> to go to line\rLinks to moved pages have been changed.\r"
  342.         html::SetWin
  343.     }
  344.     bringToFront "* Remote URLs *"
  345.     setWinInfo read-only 0
  346.     goto [maxPos]
  347.     insertText "Line [lindex $id 0]: "
  348.     insertColorEscape [getPos] $color 
  349.     insertText "$str"
  350.     insertColorEscape [getPos] 0
  351.     insertText " [lindex $id 1]\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t∞$win\r"
  352.     incr htmlNumBbthChecking -1
  353.     if {!$htmlNumBbthChecking} {insertText "Done.\r"}
  354.     refresh
  355.     setWinInfo dirty 0
  356.     setWinInfo read-only 1
  357. }
  358.  
  359. # Returns a list of all HTML and CSS files in a folder and its subfolders.
  360. proc html::AllHTMLfiles {folder {CSS 0} {toExclude ""}} {
  361.     message "Building file list…"
  362.     set filelist [html::OpenAfile]
  363.     set fid [lindex $filelist 0]
  364.     set files [lindex $filelist 1]
  365.     set folders [list $folder]
  366.     while {[llength $folders]} {
  367.         set newFolders ""
  368.         foreach fl $folders { 
  369.             html::GetHTMLfiles $fl $CSS $fid $toExclude
  370.             # Get folders in this folder.
  371.             append newFolders " " [glob -nocomplain -t d -dir $fl *]
  372.         }
  373.         set folders $newFolders
  374.     }
  375.     close $fid
  376.     return $files
  377. }
  378.  
  379. # Finds all HTML files in a folder
  380. proc html::GetHTMLfiles {folder {CSS 0} {fid ""} {toExclude ""}} {
  381.     global filepats 
  382.     set pats $filepats(HTML)
  383.     if {$CSS && [info exists filepats(CSS)]} {append pats " " $filepats(CSS)}
  384.     set files ""
  385.     set cl 0
  386.     if {$fid == ""} {
  387.         set filelist [html::OpenAfile]
  388.         set fid [lindex $filelist 0]
  389.         set files [lindex $filelist 1]
  390.         set cl 1
  391.     }
  392.     if {![catch {glob -t TEXT -dir $folder *} filelist]} {
  393.         foreach fil $filelist {
  394.             foreach suffix $pats {
  395.                 if {[string match $suffix $fil] && ![lcontains toExclude $fil]} {
  396.                     puts $fid $fil
  397.                     break
  398.                 }
  399.             }
  400.         }
  401.     }
  402.     if {$cl} {close $fid}
  403.     return $files
  404. }
  405.  
  406. # Opens a filelist file. Returns fileid and path.
  407. proc html::OpenAfile {{macroman 0}} {
  408.     global html::TmpFolder tcl_platform
  409.     file::ensureDirExists ${html::TmpFolder}
  410.     set i 0
  411.     while {[file exists [file join ${html::TmpFolder} tempfile$i]]} {incr i}
  412.     set fid [open [file join ${html::TmpFolder} tempfile$i] w+]
  413.     if {$macroman && $tcl_platform(platform) != "macintosh"} {
  414.         fconfigure $fid -encoding macRoman
  415.     }
  416.     return [list $fid [file join ${html::TmpFolder} tempfile$i]]
  417. }
  418.  
  419.  
  420.  
  421. # checking = 1 or 2: called from html::CheckLinks
  422. # checking = 1:
  423. # Scan a list of files for HTML links and check if they point to existing files.
  424. # checking = 2:
  425. # Scan a list of files for HTML links and return the remote ones for checking with Big Brother.
  426. # checking = 0: called from htmlMoveFiles
  427. # Build a list of links which point to the files just moved.
  428. proc html::ScanFiles {files baseURL basePath homepage isInFolder checking filebase {movedFiles ""}} {
  429.     global HTMLmodeVars file::separator
  430.     global tileLeft tileTop tileWidth errorHeight
  431.     global htmlCaseFolders htmlCaseFiles
  432.  
  433.     set htmlCaseFolders ""; set htmlCaseFiles ""
  434.     set chCase $HTMLmodeVars(caseSensitive)
  435.     set chAnchor $HTMLmodeVars(checkAnchors)
  436.     
  437.     # Build regular expressions with URL attrs.    
  438.     set expBase "<base\[ \\t\\n\\r\]+\[^>\]*>"
  439.     set expBase2 "(href\[ \\t\\n\\r\]*=\[ \\t\\n\\r\]*)(\"\[^\"\]+\"|'\[^'\]+'|\[^ \\t\\n\\r\"'>\]+)"
  440.     set exp1 "<!--|<\[^<>\]+\[ \\t\\n\\r\]+[html::URLregexp]"
  441.     set exp2 {/\*|[ \t\r\n]+(url)\([ \t\r\n]*("[^"]+"|'[^']+'|[^ "'\t\n\r\)]+)[ \t\r\n]*\)}
  442.     set toCheck ""
  443.     if {$checking != 2} {
  444.         set result [html::OpenAfile 1]
  445.         set fidr [lindex $result 0]
  446.     }
  447.     set checkFail 0
  448.     
  449.     set commStart1 "<!--"
  450.     set commEnd1 "-->"
  451.     set commStart2 {/*}
  452.     set commEnd2 {\*/}
  453.     
  454.     # Open file with filelist
  455.     set fid0 [open $files]
  456.  
  457.     while {![eof $fid0]} {
  458.         gets $fid0 f
  459.         if {$f == "" || [catch {open $f} fid]} {continue}
  460.         set base $baseURL
  461.         set path $basePath
  462.         set hpPath $homepage
  463.         if {$isInFolder == ""} {
  464.             set epath $f
  465.         } else {
  466.             set epath [string range $f [expr {[string length $isInFolder] + 1}] end]
  467.         }
  468.         regsub -all ${file::separator} $epath {/} epath
  469.         set baseText ""
  470.         message "Looking at [file tail $f]…"
  471.         set filecont [read $fid 16384]
  472.         set limit [expr {[eof $fid] ? 0 : 300}]
  473.         if {[regexp {\n} $filecont]} {
  474.             set newln "\n"
  475.         } else {
  476.             set newln "\r"
  477.         }
  478.         # Look for BASE.
  479.         if {[regexp -nocase -indices $expBase $filecont thisLine]} {
  480.             set preBase [string range $filecont 0 [lindex $thisLine 0]]
  481.             set comm 0
  482.             while {[regexp -indices {<!--} $preBase bCom]} {
  483.                 set preBase [string range $preBase [expr {[lindex $bCom 1] - 1}] end]
  484.                 set comm 1
  485.                 if {[regexp -indices -- {-->} $preBase bCom]} {
  486.                     set preBase [string range $preBase [expr {[lindex $bCom 1] - 1}] end]
  487.                     set comm 0
  488.                 } else {
  489.                     break
  490.                 }
  491.             }
  492.             if {!$comm && [regexp -nocase $expBase2 [string range $filecont [lindex $thisLine 0] [lindex $thisLine 1]] href b url]} {
  493.                 set url [string trim $url "\"' \t\r\n"]
  494.                 if {![catch {html::BASEpieces $url} basestr]} {
  495.                     set base [lindex $basestr 0]
  496.                     set path [lindex $basestr 1]
  497.                     set epath [lindex $basestr 2]
  498.                     set hpPath ""
  499.                     set baseText "(BASE used) "
  500.                 } else {
  501.                     set baseText "(Invalid BASE) "
  502.                 }
  503.             }
  504.         }
  505.         for {set i1 1} {$i1 < 3} {incr i1} {
  506.             set exprr [set exp$i1]
  507.             if {$i1 == 2} {
  508.                 seek $fid 0
  509.                 set filecont [read $fid 16384]
  510.                 set limit [expr {[eof $fid] ? 0 : 300}] 
  511.             }
  512.             set commStart [set commStart$i1]
  513.             set commEnd [set commEnd$i1]
  514.             set linenum 1
  515.             set comment 0
  516.             while {1} {
  517.                 # Find all links in every line.
  518.                 while {$comment || ([regexp -nocase -indices $exprr $filecont href attr url] &&
  519.                 [expr {[string length $filecont] - [lindex $href 0]}] > $limit)} {
  520.                     # Comment?
  521.                     if {$comment || [string range $filecont [lindex $href 0] [lindex $href 1]] == $commStart} {
  522.                         if {$comment} {
  523.                             set href {0 0}
  524.                             set subcont $filecont
  525.                         } else {
  526.                             set subcont [string range $filecont [expr {[lindex $href 1] + 1}] end]
  527.                         }
  528.                         if {[regexp -indices -- $commEnd $subcont cend] &&
  529.                         [expr {[string length $subcont] - [lindex $cend 0]}] > $limit} {
  530.                             incr linenum [regsub -all $newln [string range $filecont 0 [expr {[lindex $href 1] + [lindex $cend 1]}]] {} dummy]
  531.                             set filecont [string range $filecont [expr {[lindex $href 1] + [lindex $cend 1]}] end]
  532.                             set comment 0
  533.                             continue
  534.                         } else {
  535.                             set comment 1
  536.                             break
  537.                         }
  538.                     }
  539.                     incr linenum [regsub -all $newln [string range $filecont 0 [lindex $url 0]] {} dummy]
  540.                     set linkTo [html::URLunEscape [string trim [string range $filecont [lindex $url 0] [lindex $url 1]] "\"' \t\r\n"]]
  541.                     set nogood 0
  542.                     if {[catch {html::PathToFile $base $path $epath $hpPath $linkTo} linkToPath]} {
  543.                         if {$linkToPath == ""} {
  544.                             set nogood 1
  545.                         } elseif {$checking == 2 && [string range $linkToPath 0 6] == "http://"} {
  546.                             # Checking remote links
  547.                             lappend toCheck [list $linenum $linkToPath]
  548.                         }
  549.                         set linkToPath ""
  550.                     } else {
  551.                         # Anchors always point to the file itself, unless there's a BASE. 
  552.                         if {[string index $linkTo 0] == "#" && $baseText == ""} {set linkToPath [list $f $f]}
  553.                         set casePath [lindex $linkToPath 1]
  554.                         set linkToPath [lindex $linkToPath 0]
  555.                     }
  556.                     # If this is BASE HREF, ignore it.
  557.                     if {[string length $baseText] && [regexp -nocase -indices $expBase $filecont thisLine] \
  558.                     && [regexp -nocase $expBase2 [string range $filecont [lindex $thisLine 0] [lindex $thisLine 1]]]\
  559.                     && [lindex $thisLine 0] < [lindex $url 0] && [lindex $thisLine 1] > [lindex $url 1]} {
  560.                         set linkToPath ""
  561.                     }
  562.                     if {$checking == 1} {
  563.                         set anchorCheck 1
  564.                         set caseOK 1
  565.                         set fext [file exists $linkToPath]
  566.                         if {$chAnchor && $linkToPath != "" && [regexp {#} $linkTo] && $fext} {set anchorCheck [html::CheckAnchor $linkToPath $linkTo]}
  567.                         if {$chCase && $linkToPath != "" && $fext} {set caseOK [html::CheckLinkCase $linkToPath $casePath]}
  568.                         # Does the file exist? Ignore it if it's outside home page folder.
  569.                         # Then it point to someone else's home page.
  570.                         if {!$anchorCheck || $nogood || !$caseOK || ( $linkToPath != "" && !$fext)} {
  571.                             set bText $baseText
  572.                             if {!$anchorCheck} {append bText "(anchor missing) "}
  573.                             if {!$caseOK} {append bText "(case doesn't match) "}
  574.                             if {$homepage == ""} {
  575.                                 set line [string range $f $filebase end]
  576.                             } else {
  577.                                 set line [string range $f [expr {[string length $isInFolder] + 1}] end]
  578.                             }
  579.                             set l [expr {20 - [string length [file tail $f]]}]
  580.                             set ln [expr {5 - [string length $linenum]}]
  581.                             set href [string trim [string range $filecont [lindex $attr 0] [lindex $href 1]]]
  582.                             set lnum [expr {$linenum - [regsub -all "\n\r|\r|\n" $href "" href]}]
  583.                             append line "[format "%$l\s" ""] Line $lnum:[format "%$ln\s" ""]$bText$href"\
  584.                             "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t∞$f"
  585.                             puts $fidr $line
  586.                             set checkFail 1
  587.                         }
  588.                     } elseif {!$checking && [lcontains movedFiles $linkToPath]} {
  589.                         set href [string trim [string range $filecont [lindex $href 0] [lindex $href 1]]]
  590.                         set lnum [expr {$linenum - [regsub -all "\n\r|\r|\n" $href "" href]}]
  591.                         puts $fidr [list $f $lnum $base $path $epath $linkToPath $href]
  592.                     }
  593.                     set filecont [string range $filecont [lindex $url 1] end]
  594.                 }
  595.                 if {![eof $fid]} {
  596.                     incr linenum [regsub -all $newln [string range $filecont 0 [expr {[string length $filecont] - 301}]] {} dummy]
  597.                     set filecont "[string range $filecont [expr {[string length $filecont] - 300}] end][read $fid 16384]"
  598.                     set limit [expr {[eof $fid] ? 0 : 300}] 
  599.                 } else {
  600.                     break
  601.                 }
  602.             }
  603.         }
  604.         close $fid
  605.     }
  606.     close $fid0
  607.     catch {file delete $files}
  608.     catch {unset htmlCaseFolders htmlCaseFiles filecont}
  609.     message ""
  610.     if {$checking == 1} {
  611.         if {$checkFail} {
  612.             seek $fidr 0
  613.             new -n "* Invalid URLs *" -g $tileLeft $tileTop $tileWidth $errorHeight -m Brws
  614.             insertText "Incorrect links:  (<uparrow> and <downarrow> to browse, <return> to go to file,\ropt-<return> to select a new file)\r[read $fidr]"
  615.             html::SetWin
  616.         } else {
  617.             alertnote "All links are OK."
  618.         }
  619.         close $fidr
  620.         catch {file delete [lindex $result 1]}
  621.     } elseif {!$checking} {
  622.         return $result
  623.     } else {
  624.         return $toCheck
  625.     }
  626. }
  627.  
  628. proc html::CheckAnchor {anchorFile url} {
  629.     regexp {[^#]*#(.*)} $url dum anchor
  630.     if {[catch {open $anchorFile r} fid]} {return 1}
  631.     set exp "<!--|<(A|MAP)\[ \t\r\n\]+\[^<>\]*NAME\[ \t\n\r\]*=\[ \t\n\r\]*(\"\[ \t\n\r\]*$anchor\[ \t\n\r\]*\"|'\[ \t\n\r\]*$anchor\[ \t\n\r\]*'|$anchor)(>|\[ \t\r\n\]+\[^<>\]*>)"
  632.     set filecont [read $fid 16384]
  633.     set limit [expr {[eof $fid] ? 0 : 300}]
  634.     set comment 0
  635.     while {1} {
  636.         while {$comment || ([regexp -nocase -indices $exp $filecont anch] &&
  637.         [expr {[string length $filecont] - [lindex $anch 0]}] > $limit)} {
  638.             if {$comment || [string range $filecont [lindex $anch 0] [lindex $anch 1]] == "<!--"} {
  639.                 if {$comment} {
  640.                     set anch {0 0}
  641.                     set subcont $filecont
  642.                 } else {
  643.                     set subcont [string range $filecont [expr {[lindex $anch 1] + 1}] end]
  644.                 }
  645.                 if {[regexp -indices -- "-->" $subcont cend] &&
  646.                 [expr {[string length $subcont] - [lindex $cend 0]}] > $limit} {
  647.                     set filecont [string range $filecont [expr {[lindex $anch 1] + [lindex $cend 1]}] end]
  648.                     set comment 0
  649.                     continue
  650.                 } else {
  651.                     set comment 1
  652.                     break
  653.                 }
  654.             } else {
  655.                 close $fid
  656.                 return 1
  657.             }
  658.         } 
  659.         if {![eof $fid]} {
  660.             set filecont "[string range $filecont [expr {[string length $filecont] - 300}] end][read $fid 16384]"
  661.             set limit [expr {[eof $fid] ? 0 : 300}] 
  662.         } else {
  663.             break
  664.         }
  665.     }
  666.     close $fid
  667.     return 0
  668. }
  669.  
  670. # Checks that the case in a link match the case in the path to file.
  671. proc html::CheckLinkCase {path link} {
  672.     global htmlCaseFolders htmlCaseFiles file::separator
  673.     
  674.     set path [string trimright $path ${file::separator}]
  675.     set link [string trimright $link ${file::separator}]
  676.     if {[lcontains htmlCaseFiles $path]} {return 1}
  677.     set path [file split $path]
  678.     set plen [llength $path]
  679.     set llen [llength [file split $link]]
  680.     set j [expr {$plen - $llen ? $plen - $llen - 1 : 0}]
  681.     for {set i $j} {$i < $plen - 1} {incr i} {
  682.         set l [lindex $path [expr {$i + 1}]]
  683.         set psub [eval file join [lrange $path 0 $i]]
  684.         if {![lcontains htmlCaseFolders $psub]} {
  685.             lappend htmlCaseFolders $psub
  686.             append htmlCaseFiles " " [glob -nocomplain -dir $psub *]
  687.         }
  688.         if {![lcontains htmlCaseFiles [file join $psub $l]]} {return 0}
  689.     }
  690.     return 1
  691. }
  692.  
  693.